home *** CD-ROM | disk | FTP | other *** search
/ C/C++ Users Group Library 1996 July / C-C++ Users Group Library July 1996.iso / vol_100 / 122_01 / pbase2 < prev    next >
Encoding:
Text File  |  1984-03-05  |  22.3 KB  |  1,099 lines
  1. % *********************************************************
  2. % *                              *
  3. % * PISTOL-Portably Implemented Stack Oriented Language      *
  4. % *            Version 2.0              *
  5. % * (C) 1983 by    Ernest E. Bergmann              *
  6. % *        Physics, Building #16              *
  7. % *        Lehigh Univerisity              *
  8. % *        Bethlehem, Pa. 18015              *
  9. % *                              *
  10. % * Permission is hereby granted for all reproduction and *
  11. % * distribution of this material provided this notice is *
  12. % * included.                          *
  13. % *                              *
  14. % *********************************************************
  15. % BASIC DEFINITIONS FOR PISTOL 2.0
  16. %
  17. % DECIMAL mode initially
  18. %
  19. +5 W * USER + W@ W@ % used for 'LAST-PRIMITIVE
  20. 'W*  W 1 - IF : W * ;
  21.     ELSE $: ;$
  22.     THEN
  23. 'USER+ USER IF $: USER + ;$
  24.         ELSE $: ;$
  25.         THEN
  26. 'TRANS $: W* USER+ ;$ % TRANSLATES LOGICAL ADDRESSES TO ACTUAL RAM ADDR.
  27.         % TRANS MUST USE "$:" FOR THE 'DIS PACKAGE
  28. 'TRANS@ : TRANS W@ ;
  29. 'ARGPATCH : +5 TRANS@  W@ W + W! ; % for 'CONSTANT 'VARIABLE, 'ARRAY
  30. 'CONSTANT : : 0 ; ARGPATCH ;
  31.  
  32. 'LAST-PRIMITIVE         CONSTANT
  33.  
  34. -1    'TRUE            CONSTANT
  35. 0    'FALSE            CONSTANT
  36.  
  37. -21    TRANS@    'MININT        CONSTANT
  38. -20    TRANS@    'MAXLINNO    CONSTANT
  39. -19    TRANS@    'CHKLMT        CONSTANT
  40. -18    TRANS@    'RAMMIN        CONSTANT
  41. -17    TRANS@    'STRINGSMIN    CONSTANT
  42. -16    TRANS@    'STRINGSMAX    CONSTANT
  43. -15    TRANS@    'VBASE        CONSTANT
  44. -14    TRANS@    'VSIZE        CONSTANT
  45. VBASE VSIZE W* + 'VMAX        CONSTANT
  46. -13    TRANS@    'CSIZE        CONSTANT
  47. -12    TRANS@    'LSIZE        CONSTANT
  48. -11    TRANS@    'RSIZE        CONSTANT
  49. -10    TRANS@    'SSIZE        CONSTANT
  50. -9    TRANS@    'LINEBUF    CONSTANT
  51. LINEBUF 200 + 'EDITBUF        CONSTANT
  52. -8    TRANS@    'COMPBUF    CONSTANT
  53. -7    TRANS@    'RAMMAX        CONSTANT
  54. -6    TRANS@    'MAXORD        CONSTANT
  55. -5    TRANS@    'MAXINT        CONSTANT
  56. -4    TRANS@    'VERSION    CONSTANT
  57. -3    TRANS@ 'NEWLINE        CONSTANT
  58. -2    TRANS@    'READ_PROTECT    CONSTANT
  59. -1    TRANS@    'WRITE_PROTECT    CONSTANT
  60.  
  61. 'ON : TRUE SWAP W! ;
  62. 'OFF : FALSE SWAP W! ;
  63. 'INFILE : +7 TRANS@ ;
  64.  
  65. 'BYE : +31 TRANS ON ;
  66. +34    TRANS    'ABORT-PATCH    CONSTANT
  67. +33    TRANS    'CONVERT-PATCH    CONSTANT
  68. +32    TRANS    'PROMPT-PATCH    CONSTANT
  69. +29    TRANS '(PISTOL<)    CONSTANT
  70. +28    TRANS '.V        CONSTANT
  71. +24    TRANS '#GET-ADDR CONSTANT % FOR PATCHING #GETLINE
  72. +23    TRANS 'TAB-SIZE        CONSTANT
  73. +22    TRANS 'TRACE-ADDR     CONSTANT
  74. +21    TRANS 'ENDCASE-PATCH    CONSTANT
  75. +20    TRANS 'COLUMN        CONSTANT
  76. +19    TRANS 'TERMINAL-WIDTH    CONSTANT
  77. +18    TRANS '#LINES        CONSTANT
  78. +17    TRANS 'TERMINAL-PAGE    CONSTANT
  79. +16    TRANS 'COMPILE-END-PATCH CONSTANT
  80. +15    TRANS 'TRACE-LEVEL    CONSTANT % USED AS BOOLEAN
  81.                     % AND LEVEL INDICATOR
  82. +13    TRANS 'RAISE        CONSTANT
  83. +11    TRANS 'NEXTCH^        CONSTANT
  84. +10    TRANS 'CONSOLE        CONSTANT
  85. +9    TRANS 'ECHO        CONSTANT
  86. +8    TRANS 'LIST        CONSTANT
  87. +6    TRANS 'PREVIOUS        CONSTANT % UPDATED BY (V)FIND
  88. +5    TRANS 'CURRENT        CONSTANT
  89. +4    TRANS 'OLD-EOSTRINGS    CONSTANT % END OF PERMANENT
  90.                     % STRINGS VARIABLE
  91. +3    TRANS 'CURRENT-EOSTRINGS CONSTANT
  92. +2    TRANS '.D        CONSTANT
  93. +1    TRANS '.C        CONSTANT
  94. +0    TRANS 'RADIX        CONSTANT
  95. STRINGSMIN 'RADIX-INDICATOR    CONSTANT
  96. STRINGSMIN 1 + 'SYNTAXBASE    CONSTANT
  97.  
  98. 'NOP : ;
  99. 'DUP : 0 S@ ;
  100. '1+ : 1 + ;
  101. '1- : 1 - ;
  102. 'W+ : W + ;
  103. 'W- : W - ;
  104. 'W<- : SWAP W! ;
  105. '1+W! : DUP W@ 1+ W<- ;
  106. 'W+W! : DUP W@ W+ W<- ;
  107. 'CR : NEWLINE TYO ;
  108. 'SPACE : 32 TYO ;
  109. 'SPACES : 0 DO SPACE LOOP ;
  110. 'DDUP : 1 S@ 1 S@ ;
  111. 'OVER : 1 S@ ;
  112. '2OVER : 2 S@ ;
  113. '3OVER : 3 S@ ; % USED BY DIS PACKAGE(DON'T CHANGE!)
  114. 'UNDER : SWAP DROP ;
  115. 'TYPE : 0 DO DUP C@ TYO 1+ LOOP DROP ;
  116. 'LT : MININT SWAP 1- .. ;
  117. 'GT : 1+ MAXINT .. ;
  118. 'LINE-SPACE? : COLUMN W@ + TERMINAL-WIDTH W@ LT
  119.     IF ELSE CR THEN ;
  120.  
  121. 'MSG : DUP C@ LINE-SPACE?
  122.      DUP 1+ SWAP C@ TYPE ;
  123.  
  124. 'IFCR : COLUMN W@ 0 GT IF CR THEN ;
  125. 'ERR : IFCR ABORT ;
  126.  
  127. 'MERR : CONSOLE ON MSG ERR ;
  128.  
  129.  
  130. 'INDENT : DUP TERMINAL-WIDTH W@ LT IF
  131.     COLUMN W@ - SPACES
  132.     ELSE IFCR DROP
  133.     THEN ;
  134.  
  135. 'TAB : 9 TYO ;
  136.  
  137. 'TABS : 0 DO TAB LOOP ;
  138.  
  139. 'ALLOT : W* .D W@ + .D W! ; % advances dictionary pointer
  140.             % by the amount given by top of stack
  141. 'W, :        % PLACES TOS AT END OF DICTIONARY
  142.     .D W@ W! 1 ALLOT
  143.     ;
  144. 'VARIABLE : : 3 ;    % create definition
  145.     .D W@ ARGPATCH    % point it at end of dictionary
  146.     W,        % initialize variable
  147.     ;        % finish with allocating space
  148. 'ARRAY : : 3 ;        % create definition
  149.     .D W@ ARGPATCH    % point it at end of dictionary
  150.     ALLOT ;        % allocate requested space and ;
  151.  
  152.  
  153. % VOCABULARY RELATED DEFINITIONS:
  154. '> : .V W@ DUP VBASE GT    % "POPS" VOCABULARY STACK
  155.     IF W- .V W!
  156.     ELSE "*** VSTACK UNDERFLOW***" MERR
  157.     THEN
  158.     ;
  159.  
  160. '<V :    % TRANSFERS TOS TO TOP OF VSTACK
  161.     .V W@ DUP VMAX LT
  162.     IF W+ DUP .V W! W!
  163.     ELSE "*** VSTACK OVERFLOW***" MERR
  164.     THEN
  165.     ;
  166.  
  167. 'PISTOL< : (PISTOL<) <V ;
  168.  
  169.  
  170. (PISTOL<)    'BRANCH-LIST    VARIABLE
  171.  
  172. 'BRANCH :    % CREATES AN ARRAY OF TWO ELEMENTS
  173.         % AND A PROCEDURE THAT PUSHES A ^
  174.         % TO THE FIRST ELEMENT OF THE ARRAY
  175.         % THIS FIRST ELEMENT CONTAINS A ^
  176.         % TO THE CURRENT HEAD OF THE VOCABULARY
  177.         % BRANCH AND THE SECOND ELEMENT IS A
  178.         % BACKWARD LINK TO THE PREVIOUS HEAD.
  179.         % BRANCH-LIST CONTAINS THE ^ TO THE
  180.         % THREADED LIST OF BRANCHES THAT HAVE
  181.         % BEEN DEFINED; THE BACKWARD LINK FOR
  182.         % (PISTOL<) IS "NIL"
  183. : 3 <V ; .D W@ ARGPATCH
  184.     0 .D W@ W!
  185.     BRANCH-LIST W@ .D W@ W+
  186.     W!
  187.     .D W@ BRANCH-LIST
  188.     W!
  189.     2 ALLOT
  190.     ;
  191.  
  192. 'UNLINKED< BRANCH    % CAN BE USED FOR RARELY USED, OBSCURE,
  193.         % OR DANGEROUS WORDS
  194.  
  195. CURRENT W@ W@ W+ W@ '(UNLINKED<) CONSTANT    % PROVIDES POINTER
  196.                     % TO HEAD OF THIS VOCAB.
  197.  
  198.  
  199. '3W- : W- W- W- ;
  200.  
  201. 'BLIST :    % LISTS THE NAMES OF ALL DEFINED BRANCHES
  202.     BRANCH-LIST W@
  203.     BEGIN
  204.         DUP W+ W@ DUP    % GET LINK
  205.         IF
  206.             SWAP 3W- 3W-
  207.             W@ MSG CR
  208.     REPEAT
  209.     DROP DROP
  210.     IFCR
  211.     'PISTOL< MSG
  212.     ;
  213.  
  214. % DO LOOP INDICES:
  215. 'I : 0 L@ ;
  216. 'J : 3 L@ ;
  217. 'K : 6 L@ ;
  218.  
  219. 'I' : 2 L@ 1 L@ + 1- 0 L@ - ;
  220. 'J' : 5 L@ 4 L@ + 1- 3 L@ - ;
  221. 'K' : 8 L@ 7 L@ + 1- 6 L@ - ;
  222.  
  223. % SOME LOGICAL OPERATORS:
  224.  
  225. 'LOR : IF DROP TRUE THEN ;        % LOGICAL OR
  226.  
  227. 'LAND : IF ELSE DROP FALSE THEN ;    % LOGICAL AND
  228.  
  229. 'LNOT : IF FALSE ELSE TRUE THEN ; % LOGICAL NEGATION
  230.  
  231. 'MINUS : 0 SWAP - ;
  232. 'LTZ    : MININT -1 .. ;
  233. 'GTZ    : 1 MAXINT .. ;
  234. 'EQZ    : LNOT    ;
  235. 'ABS    : DUP LTZ IF MINUS THEN ;
  236. 'EQ    : - LNOT ;
  237. 'LE : MININT SWAP .. ;
  238. 'GE : MAXINT .. ;
  239. 'MIN : DDUP GE IF SWAP THEN DROP ;
  240.  
  241. 'MAX : DDUP GE IF THEN SWAP DROP ;
  242.  
  243.  
  244. % NUMBER OUTPUT ROUTINE:
  245.  
  246. % ASCII <-- DIGIT
  247. 'ASCII : DUP 9 GT IF 55
  248.         ELSE 48
  249.     THEN + ;
  250.  
  251. '<U#> : -1 SWAP
  252.     BEGIN RADIX W@ /MOD ABS SWAP DUP LNOT END
  253.     DROP ;
  254.  
  255. '#TYPE : BEGIN DUP -1 GT IF ASCII TYO REPEAT DROP ;
  256.  
  257. '= : DUP 0 LT IF  45 TYO MINUS THEN
  258.     <U#> #TYPE ;
  259. '? : W@ = ;
  260.  
  261. % BELOW ARE WORDS THAT CONTROL DISPLAY OF CODE PRODUCED
  262. % BY THE COMPILER; CAN BE USEFUL FOR DEBUGGING AND EDUCATION
  263.  
  264. 'CODESHOW : IFCR "COMPILE BUFFER CONTAINS:" MSG CR
  265.     COMPBUF    BEGIN DUP ? TAB W+
  266.             .C W@ OVER GT LNOT
  267.         END
  268.     DROP IFCR
  269.     ;
  270. 'SHOWCODE : 0 COMPILE-END-PATCH W! ; 'CODESHOW FIND ARGPATCH
  271.  
  272. 'NOSHOWCODE : COMPILE-END-PATCH OFF ;
  273.  
  274. 'PROMPT :        % DUPLICATES PRIMITIVE PROMPT
  275.     IFCR        % FUNCTION
  276.     SP IF SP = THEN    % EXCEPT STACK SIZE SHOWN
  277.     RADIX-INDICATOR C@ TYO
  278.     SYNTAXBASE MSG
  279.     "> " MSG
  280.     ;
  281. 'PROMPT FIND PROMPT-PATCH W!    % PATCHING IT
  282.  
  283. 'ADDRESS :    DUP FIND DUP
  284.         IF
  285.             UNDER
  286.         ELSE
  287.             IFCR 39 TYO DROP MSG
  288.             " NOT FOUND" MERR
  289.         THEN
  290.     ;
  291.  
  292. '/ : /MOD DROP ;
  293. 'MOD : /MOD UNDER ;
  294.  
  295.  
  296. % CHANGING NUMBER BASES:
  297. 'HEX : 72 RADIX-INDICATOR C! 16 RADIX W! ;
  298. 'DECIMAL : 88 RADIX-INDICATOR C! 10 RADIX W! ;
  299. 'OCTAL : 81 RADIX-INDICATOR C! 8 RADIX W! ;
  300. 'BINARY : 66 RADIX-INDICATOR C! 2 RADIX W! ;
  301.  
  302.  
  303. %
  304. 'STACK : IFCR 40 TYO SP = 41 TYO % (STACKSIZE)
  305.     SP SP 12 MIN 1- 0 DO 2 SPACES DUP S@ = 1- LOOP
  306.     DROP ;
  307. %
  308. 'RSTACK : IFCR 'R( MSG RP 1- = 41 TYO % RSTACK SIZE
  309.     RP 1- DUP 12 MIN 0 DO 2 SPACES DUP R@ = 1-
  310.     LOOP DROP ;
  311.  
  312. % RECURSE ALOWS ROUTINE OR COMPBUF TO CALL ITSELF
  313. 'RECURSE :    1 R@ W-    % FIND IN WHICH WORD
  314.         0 R@ W- % FIND WHERE IS RECURSE USED
  315.         W!    % PATCH
  316.     R> W- <R        % BACKUP TO EXEC PATCH
  317.     ;
  318. %
  319. 'TELL : W- W- W@  MSG ;
  320.  
  321. 'NEXT-LINK : 3W- W@ ;
  322. %
  323. % THIS BOMBS WHEN > NUMINSTRUCTIONS
  324. 'PNAME : DUP IF
  325.         LAST-PRIMITIVE
  326.         BEGIN    DUP
  327.             IF    DDUP W@ EQ
  328.                 IF    TELL    TRUE
  329.                 ELSE    NEXT-LINK FALSE
  330.                 THEN
  331.             ELSE    '(NO_NAME) MSG    LNOT
  332.             THEN
  333.         END
  334.         DROP
  335.         ELSE '; MSG DROP
  336.         THEN
  337.     ;
  338. %
  339. 'NAME : DUP PRIMITIVE? IF
  340.     PNAME
  341.     ELSE TELL
  342.     THEN ;
  343.  
  344.  
  345. % VOCABULARY MAINTENANCE PACKAGE:
  346.  
  347. % LLIST ADDRESS AND NAME:
  348. 'LNAME : DUP = 3 SPACES NAME CR ;
  349.  
  350. % LIST LAST TEN WORDS:
  351. 'NEXT10 : IFCR 10 0 DO DUP LNOT IF ERR THEN
  352.         DUP LNAME NEXT-LINK LOOP
  353.     ;
  354. 'TOP10 :    % OF VOCBULARY TO WHICH DEFINITIONS
  355.         % ARE CURRENTLY BEING ADDED
  356.     CURRENT W@ W@ NEXT10 ;
  357.  
  358. 'VLIST : % TOP TEN WORDS IN FIRST VOCABULARY TO BE SEARCHED
  359.     .V W@ W@ W@ NEXT10 ;
  360.  
  361. 0 'ITEM VARIABLE
  362.  
  363. 'FIND_PREVIOUS,NEXT :    % GIVEN THREAD, FINDS ENTRY MOST
  364.             % RECENT AFTER ITEM AND THE ONE
  365.             % JUST BEFORE IT
  366.             % EXIT: PREV(LATER CHRON),NEXT
  367.     BEGIN
  368.         DUP NEXT-LINK DUP ITEM W@ GT
  369.     IF
  370.         UNDER
  371.     REPEAT
  372.     ;
  373. % IMPROVED FORGET DEVELOPED AUG 8, 1982
  374.  
  375. 0 'FENCE    VARIABLE
  376.  
  377. 'VFORGET :    % TOS IS A VOCABULARY TO BE CUT BACK
  378.         % TO BEFORE "ITEM"
  379.     DUP W@
  380.     DUP ITEM W@ GT
  381.     IF
  382.         FIND_PREVIOUS,NEXT UNDER W<-
  383.     ELSE
  384.         DROP DROP
  385.     THEN
  386.     ;
  387.  
  388.  
  389. 'FORGET : ADDRESS DUP ITEM W!    % SIMPLIFIES LOGIC!
  390.     FENCE W@ GT
  391.     IF
  392.         VBASE .V W!    % RESET VSTACK
  393.         (PISTOL<) CURRENT W!
  394.         BRANCH-LIST W@
  395.         BEGIN
  396.             ITEM W@ OVER LT
  397.         IF
  398.             W+ W@
  399.         REPEAT
  400.         DUP BRANCH-LIST W!
  401.         BEGIN        % TRIM EACH VOCAB
  402.             DUP VFORGET
  403.             W+ W@ DUP
  404.         IF
  405.         REPEAT
  406.         DROP
  407.         ITEM W@
  408.         DUP W- W- W@
  409.         DUP OLD-EOSTRINGS W!
  410.         CURRENT-EOSTRINGS W!
  411.         3W- DUP W@ CURRENT W@ W!
  412.         W- .D W!
  413.     ELSE
  414.         "BELOW FENCE" MERR
  415.     THEN
  416. ;
  417.  
  418. 'FORGET FIND FENCE W!    % SET FENCE
  419.  
  420. 'VADDRESS :    % TAKES NAME,VOCAB ON STACK; GETS ITS ADDRESS
  421.         % RETURNS IT ON TOP OF STACK IF IN VOCAB
  422.     OVER SWAP
  423.     VFIND
  424.     DUP IF UNDER
  425.         ELSE 39 TYO DROP MSG
  426.         " NOT IN VOCABULARY" MERR
  427.         THEN
  428.     ;
  429.  
  430. 'REMOVE :    % TAKE NAME,VOCAB ON STACK ;GET ITS ADDRESS
  431.         % (SAVED IN ITEM); PUT PREVIOUS-> NEXT
  432.     DDUP VADDRESS DUP ITEM W!
  433.     DUP 2OVER W@ -            % NOT LAST DEFINED?
  434.     IF NEXT-LINK PREVIOUS W@ 3W-    % PREV->NEXT
  435.     ELSE NEXT-LINK OVER        % VOCAB->NEXT
  436.     THEN W! DROP DROP
  437.     ;
  438.  
  439. 'ADD_LINK :    % GIVEN VOCABULARY, LINK IN ITEM IN
  440.         % PROPER CHRONOLOGICAL ORDER
  441.     DUP W@ ITEM W@ LT
  442.     IF
  443.         DUP W@ ITEM W@ 3W- W!    % UPDATE VOCAB
  444.         ITEM W@ W<-        % INSTALL LINK TO
  445.                     % OLD HEAD
  446.     ELSE
  447.         W@ FIND_PREVIOUS,NEXT
  448.         ITEM W@ 3W- W!        % ADJUST LINK OF ITEM
  449.         3W- ITEM W@ W<-     % LINK PREVIOUS
  450.     THEN
  451. ;
  452.  
  453. 'UNLINK :    % TAKES STRING ON TOS AND UNLINKS IT FROM
  454.         % SEARCH PATH AND LINKS IT INTO THE
  455.         % UNLINKED< VOCABULARY BRANCH
  456.     CURRENT W@ REMOVE
  457.     (UNLINKED<) ADD_LINK
  458.     ;
  459.  
  460. 'RELINK :    % TAKES NAME ON TOS AND REMOVES IT FROM THE
  461.         % UNLINKED< VOCABULARY; LINKS IT INTO THE
  462.         % CURRENT VOCABULARY
  463.     (UNLINKED<) REMOVE
  464.     CURRENT W@ ADD_LINK
  465.     ;
  466.  
  467. 'DEFINITIONS :    % SETS CURRENT TO TOP VOCABULARY IN  IN VSTACK
  468.     .V W@ W@ CURRENT W!
  469.     ;
  470.  
  471. 'LAST-PRIMITIVE    UNLINK
  472. 'W,        UNLINK
  473. 'ALLOT        UNLINK
  474. 'CODESHOW    UNLINK
  475. 'VFORGET    UNLINK
  476. 'REMOVE        UNLINK
  477. 'ITEM        UNLINK
  478. 'LNAME        UNLINK
  479. 'FIND_PREVIOUS,NEXT    UNLINK
  480. 'ADD_LINK    UNLINK
  481. '<V        UNLINK
  482. 'PROMPT        UNLINK
  483. 'TELL        UNLINK
  484. 'PNAME        UNLINK
  485.  
  486. % CASE INDICES:
  487. 'ICASE : 0 CASE@ ;
  488. 'JCASE : 2 CASE@ ;
  489. 'CASE-ADDR : 1 CASE@ ;
  490. '(ENDCASE) : IFCR "ENDCASE ENCOUNTERED WITH VALUE = " MSG
  491.     ICASE = " AT " MSG CASE-ADDR = ERR ;
  492. '(ENDCASE) ADDRESS
  493. ENDCASE-PATCH W!    % PATCH ENDCASE
  494.  
  495. % SPECIAL STRING ROUTINES:
  496.  
  497. % PACK puts TOS onto the end of the strings area.
  498. 'PACK : CURRENT-EOSTRINGS W@ C!
  499.     CURRENT-EOSTRINGS 1+W! ;
  500.  
  501. '=PACK : CURRENT-EOSTRINGS W@ <R
  502.     CURRENT-EOSTRINGS 1+W!
  503.     DUP LTZ IF 45 PACK MINUS THEN
  504.     <U#> BEGIN DUP 0 GE IF ASCII PACK REPEAT
  505.     DROP R> CURRENT-EOSTRINGS W@ OVER -
  506.     1- OVER C! ;
  507. % =PACK IS USED TO CREATE A NUMBER STRING. IT
  508. % TAKES THE TOP SIGNED NUMBER ON STACK AND CONVERTS IT
  509. % TO A STRING THAT COULD BE OUTPUT BY MSG
  510.  
  511. % THE NEXT TWO ROUTINES TAKE AS INPUT
  512. % A BUNCH OF STRING POINTERS
  513. % AND THEIR NUMBER FROM THE TOP OF STACK.
  514. 'MSGS-COUNT : SP 1- OVER LT IF "NOT ENOUGH STRINGS"
  515.     MERR THEN
  516.     0 SWAP 1+ 1 DO I S@ C@ + LOOP ;
  517.  
  518. 'MSGS : DUP <R DUP <R MSGS-COUNT LINE-SPACE?
  519.     R> 0 DO I' S@ MSG LOOP R> 0 DO DROP LOOP
  520.     ;
  521.  
  522. 'ENDCASE-PATCH    UNLINK
  523. 'MSGS-COUNT    UNLINK
  524. 'LINE-SPACE?    UNLINK
  525.  
  526. % In the above, MSGS will output a bunch of strings
  527. % that were left on stack IN THE ORDER they were placed
  528. % on stack, trying to place them all on the same line;
  529. % failing that, it will try and not split the individual
  530. % strings across lines.  It will be used to improve the:
  531.  
  532. % DISASSEMBLER PACKAGE
  533.  
  534. 'DIS-TRIAL :    % CONTAINS ALL REL-OPS IN THE KERNEL
  535.     DO +LOOP
  536.     DO LOOP
  537.     IF ELSE
  538.     THEN
  539.     OFCASE C: ;C ENDCASE
  540.     : ;
  541.     $: ;$
  542. ;
  543. 'NEXT-TRIAL :    % CONVENIENCE TO STEP THROUGH DIS-TRIAL
  544.     W+ W+ DUP W@
  545.     ;
  546. 'OP-TYPE :    % USED TO DEFINE WORDS FOR TESTING KERNEL OPS
  547.     DUP    :
  548.         3 EQ IF "" TRUE ELSE FALSE THEN
  549.         ;
  550.         CURRENT W@ W@ 6 W* + W!    % GET THE NAME OF DEFINITION
  551.         ARGPATCH    % RECORD THE VALUE OF OPCODE
  552.     ;
  553.  
  554. '3OVER FIND    % IT STARTS WITH A LITERAL CONSTANT
  555. W@ 'LITERAL    CONSTANT
  556.  
  557. 'Z : 'Z ;
  558. 'Z  FIND    % IT STARTS WITH A STRING LITERAL
  559. W@ 'STRING-LIT    CONSTANT
  560.  
  561. 'TRANS FIND    % IT IS A "$:" WORD
  562. W- W@ '[$:]    OP-TYPE
  563.  
  564. 'DIS-TRIAL FIND
  565. DUP W- W@ '[:]        OP-TYPE
  566. NEXT-TRIAL '(+LOOP)    OP-TYPE
  567. NEXT-TRIAL '(DO)    OP-TYPE
  568. NEXT-TRIAL '(LOOP)    OP-TYPE
  569. NEXT-TRIAL '(IF)    OP-TYPE
  570. NEXT-TRIAL '(ELSE)    OP-TYPE
  571. NEXT-TRIAL '(OFCASE)    OP-TYPE
  572. NEXT-TRIAL '(C:)    OP-TYPE
  573. W+ W+
  574. NEXT-TRIAL '(:)        OP-TYPE
  575. NEXT-TRIAL '(;)        OP-TYPE
  576. W-
  577. NEXT-TRIAL '($:)    OP-TYPE
  578. DROP
  579.  
  580. 'REL-OP    :
  581.     SWAP W+ W@ =PACK
  582.     " [" SWAP ']
  583.     4 MSGS W W+
  584.     ;
  585. 'DIS-TOKEN :
  586.     DUP W@ OFCASE
  587.     (;)    C: MSG DROP W ;C
  588.     LITERAL EQ    C: W+ W@ =PACK MSG W W+ ;C
  589.     STRING-LIT EQ    C: W+ W@ '" SWAP OVER
  590.                 3 MSGS W W+    ;C
  591.     (DO)    C: REL-OP ;C
  592.     (LOOP)    C: REL-OP ;C
  593.     (+LOOP)    C: REL-OP ;C
  594.     (IF)    C: REL-OP ;C
  595.     (ELSE)    C: REL-OP ;C
  596.     (OFCASE) C: REL-OP ;C
  597.     (C:)    C: REL-OP ;C
  598.     (:)    C: REL-OP ;C
  599.     ($:)    C: REL-OP ;C
  600.     TRUE    C: NAME DROP W ;C
  601.     ENDCASE
  602.     ;
  603. 'WORD-ID : IFCR 39 TYO DUP MSG SPACE ADDRESS ;
  604.  
  605. 'DIS : WORD-ID
  606.     DUP W- DUP W@ DUP
  607.     [:] IF MSG DROP
  608.     ELSE [$:] IF MSG
  609.         ELSE "NON-STANDARD IMMEDIATE WORD"
  610.             MERR
  611.         THEN
  612.     THEN
  613.     NEXT-LINK    % GET ^ TO END OF CODE
  614.     SWAP    DO
  615.         TAB I DIS-TOKEN
  616.         +LOOP
  617.     TAB '; MSG
  618. ;
  619.  
  620. 'Z        UNLINK
  621. 'CASE-ADDR    UNLINK
  622. '(ENDCASE)    UNLINK
  623. 'PACK        UNLINK
  624. 'LITERAL    UNLINK
  625. 'STRING-LIT    UNLINK
  626. '[:]        UNLINK
  627. 'DIS-TRIAL    UNLINK
  628. 'NEXT-TRIAL    UNLINK
  629. 'OP-TYPE    UNLINK
  630. '[$:]        UNLINK
  631. '(+LOOP)    UNLINK
  632. '(DO)        UNLINK
  633. '(LOOP)        UNLINK
  634. '(IF)        UNLINK
  635. '(ELSE)        UNLINK
  636. '(OFCASE)    UNLINK
  637. '(C:)        UNLINK
  638. '(:)        UNLINK
  639. '($:)        UNLINK
  640. 'REL-OP        UNLINK
  641. 'DIS-TOKEN    UNLINK
  642.  
  643. % TRACE PACKAGE:
  644.  
  645. % ROUTINE THAT DISPLAYS THE STATE OF THE MACHINE
  646. % AT EACH TRACE AND TERMINATES TRACE AT END OF
  647. % ROUTINE BEING TRACED.
  648. '(TRACE) : STACK 48 INDENT 0 R@ W@ DUP
  649.     (;)    IF MSG DROP 0 TRACE-LEVEL W!
  650.         ELSE NAME 2 SPACES
  651.         THEN
  652.     ;
  653. % PERFORM PATCH:
  654. '(TRACE) ADDRESS TRACE-ADDR W!
  655.  
  656. 'TRACE : WORD-ID "BEING TRACED:" MSG
  657.         RP 3 + TRACE-LEVEL W!
  658.         EXEC IFCR "TRACE COMPLETED" MSG
  659.         CR
  660.     ;
  661.  
  662. '(;)        UNLINK
  663. 'WORD-ID    UNLINK
  664. '(TRACE)    UNLINK
  665.  
  666.  
  667. % EDIT PACKAGE:
  668.  
  669.  
  670. +27    TRANS    'OUTFILE-STATUS        CONSTANT
  671. +26    TRANS    'INPUTFILE-STATUS    CONSTANT
  672. STRINGSMAX 200 -
  673.     'SAFE-END        CONSTANT
  674. 1    'OLDLINE#    VARIABLE
  675. EDITBUF    'OLDLINE^    VARIABLE
  676. EDITBUF        'EOT    VARIABLE
  677.  
  678. 'NEWF : 1 OLDLINE# W!
  679.     EDITBUF OLDLINE^ W!
  680.     0 EDITBUF C!
  681.     EDITBUF EOT W!
  682.     ;
  683.  
  684. NEWF    % INITIALIZE EDITBUFFER
  685.  
  686. 'NEXTLINE : DUP C@ DUP IF + 1+
  687.         ELSE "***NO SUCH LINE***" MERR
  688.         THEN ;
  689.  
  690. 'LISTALL : 1 EDITBUF
  691.     BEGIN DUP C@
  692.     IF OVER = ": " MSG DUP MSG NEXTLINE
  693.     SWAP 1+ SWAP REPEAT DROP DROP ;
  694.  
  695. 'ILLEGLIN : "***ILLEGAL LINE #***" MERR ;
  696.  
  697.  
  698. 'LFIND : DUP OLDLINE# LT IF DUP 1 MAXLINNO ..
  699.                 LNOT IF ILLEGLIN THEN
  700.         EDITBUF OVER 1 DO
  701.             NEXTLINE LOOP
  702.         ELSE DUP OLDLINE#    % CALCULATE # OF
  703.             - OLDLINE^ W@    % LINES NEEDED TO
  704.             SWAP 0 DO
  705.             NEXTLINE LOOP    % ADVANCE
  706.         THEN
  707.         SWAP OLDLINE# W!
  708.         DUP OLDLINE^ W!
  709.     ;
  710.  
  711. 'LDIR : % CHARACTER BLOCK MOVE, INCREASING
  712.     % ON ENTRY: SOURCE, DESTINATION, #
  713.     % ON EXIT: SOURCE+#, DESTINATION+#
  714.  
  715.     0 DO OVER C@ OVER C!
  716.         1+ SWAP 1+ SWAP
  717.     LOOP
  718.     ;
  719.  
  720. 'LDDR :    % CHARACTER BLOCK MOVE, DECREASING
  721.     % ON ENTRY: SOURCE, DESTINATION, #
  722.     % ON EXIT: SOURCE-#, DESTINATION-#
  723.  
  724.     0 DO
  725.     OVER C@ OVER C!
  726.     1- SWAP 1- SWAP
  727.     LOOP
  728.     ;
  729.  
  730. '#GETLINE :    % TAKES THE LINE NUMBERED BY THE
  731.         % TOP OF THE STACK AND TRANSFERS
  732.         % IT INTO LINEBUF
  733.         LFIND
  734.         LINEBUF 1+ NEXTCH^ W!    % SYSTEM ^S
  735.         LINEBUF
  736.         OVER C@ IF    % NOT NULL LINE?
  737.             OVER C@ 1+
  738.             LDIR
  739.         ELSE
  740.             1 OVER C! 1+ NEWLINE OVER C!
  741.         THEN
  742.         DROP DROP
  743.         % ECHO IF APPROPRIATE:
  744.         ECHO W@ IF LINEBUF MSG THEN
  745.     ;
  746.  
  747. '#GETLINE FIND #GET-ADDR W!    % DO THE PATCH
  748.  
  749.  
  750. 'MTUP :    % ON ENTRY: ^ TO BAS OF BLOCK BOUNDED BY EOT
  751.     % ON EXIT: ^ TO BASE OF MOVED BLOCK AT STRINGSMAX
  752.  
  753.     EOT W@ 1+ SWAP -    % # BYTES
  754.     EOT W@ SWAP    % SOURCE
  755.     STRINGSMAX SWAP    % DESTINATION
  756.     LDDR
  757.     UNDER 1+
  758.     ;
  759.  
  760. 'OVERWRITE :    % TAKES THE ^BOTTOM OF TEXT TO BE MOVED DOWN
  761.         %    ^TEXT TO BE OVERWRITTEN
  762.         % AND    ^LAST CHAR OF TEXT TO BE MOVED DOWN
  763.  
  764.         % ON EXIT LEAVES NO ARGS BUT HAS ADJUSTED EOT
  765.  
  766.     1+ 2OVER -
  767.     LDIR
  768.     1-
  769.     EOT W!
  770.     DROP
  771.     ;
  772.  
  773.  
  774. 'MTDN :    % ON ENTRY: ^ TO BASE OF BLOCK AT STRINGSMAX
  775.     %    AND ^ TO BASE OF DESTINATION
  776.  
  777.     STRINGSMAX
  778.     OVERWRITE
  779.     ;
  780.  
  781.  
  782.  
  783. 'LENTER : % TAKES ADDRESS ON TOP OF STACK AND MOVES INPUT
  784.       % INPUT LINE THERE; LEAVES A POINTER TO NEXT AVAILABLE
  785.       % LOCATION.
  786.     LINEBUF NEXTLINE LINEBUF
  787.     DO
  788.         I C@ OVER C! 1+
  789.     LOOP
  790.     ;
  791.  
  792. '1POSARG? :    % TESTS STACK TO SEE IF THERE IS EXACTLY
  793.         % ONE ARGUMENT; IT MUST BE POSITIVE.
  794.  
  795.         % ON EXIT IT LEAVES THAT ARGUEMENT.
  796.  
  797.     SP 1 EQ OVER -1 GT LAND
  798.     LNOT
  799.     IF "NOT SINGLE, POSITIVE ARGUEMENT" MERR
  800.     THEN
  801.     ;
  802.  
  803. 'ARG#ERR : "WRONG NUMBER OF ARGUMENTS" MERR ;
  804.  
  805. 'LI : SP OFCASE
  806.     EQZ    C: LISTALL ;C
  807.     1 EQ    C: LFIND MSG ;C
  808.     2 EQ    C: DDUP GT IF OVER + 1- THEN
  809.             1+ SWAP DO I = ": " MSG
  810.                     I LFIND MSG LOOP ;C
  811.     TRUE    C: ARG#ERR ;C
  812.     ENDCASE
  813.     ;
  814.  
  815.  
  816. 'INPUT :
  817.     1POSARG?
  818.         DUP
  819.         LFIND
  820.         MTUP
  821.         SWAP DUP LFIND
  822.         BEGIN
  823.             SWAP DUP
  824.             = ": " MSG
  825.             1+ SWAP
  826.             GETLINE
  827.             LINEBUF C@ 1 GT
  828.         IF
  829.             LENTER
  830.         REPEAT
  831.         UNDER
  832.         MTDN
  833.     ;
  834.  
  835. '(DELETE) :    LFIND
  836.         DUP NEXTLINE
  837.         SWAP
  838.         EOT W@
  839.         OVERWRITE
  840.     ;
  841.  
  842. 'DELETE : 1POSARG?
  843.         (DELETE)
  844.     ;
  845.  
  846. 'REPLACE : 1POSARG?
  847.         DUP
  848.         (DELETE)
  849.         INPUT
  850.     ;
  851.  
  852. 'DELETES : SP 2 EQ
  853.         IF
  854.         DDUP LT IF OVER - 1+ THEN % IF ARG1<ARG2
  855.                     % THEN INTERPRET
  856.                     % AS RANGE !
  857.             0 DO DUP (DELETE) LOOP
  858.             DROP
  859.         ELSE
  860.             ARG#ERR
  861.         THEN
  862.     ;
  863.  
  864. '1READ :    % NO ERROR CHECKING
  865.         % TAKES A LINE FROM THE INPUT FILE AND
  866.         % APPENDS IT TO THE END OF THE
  867.         % TEXT IN THE EDIT BUFFER.
  868.  
  869.     READLINE
  870.     0 EOT W@
  871.     LENTER
  872.     DUP
  873.     EOT W!    % UPDATE EOT
  874.     C!    % EMPLACE NEW EMPTY LINE
  875.     ;
  876.  
  877. 'READ :    % TAKES A SINGLE ARGUMENT FROM STACK AS THE
  878.     % NUMBER OF LINES TO BE READ FROM THE INPUT
  879.     % FILE AND APPEND THEM TO THE END OF THE EDIT
  880.     % BUFFER.
  881.  
  882.     1POSARG?
  883.     BEGIN
  884.         EOT W@ SAFE-END LT
  885.         OVER LAND
  886.     IF
  887.         1READ
  888.         1-    % DECREASE COUNT
  889.     REPEAT
  890.     IF
  891.         "PREMATURE EOF ENCOUNTERED" MSG
  892.     THEN
  893.     ;
  894.  
  895. 'WRITE :    % TAKES A SINGLE ARGUMENT FROM STACK AS
  896.         % THE NUMBER OF LINES TO BE TRANSFERRED
  897.         % FROM THE BEGINNING OF THE EDIT BUFFER
  898.         % TO THE OUTPUT FILE.
  899.     1POSARG?
  900.     1 LFIND    % ADJUSTS POINTERS
  901.     BEGIN    % IF NOT EOT, STILL MORE LINES TO SEND
  902.         DUP C@ 2OVER LAND
  903.     IF
  904.         DUP WRITELINE
  905.         NEXTLINE
  906.         SWAP 1- SWAP
  907.     REPEAT
  908.         % AT THIS POINT HAVE POINTER TO TEXT
  909.         % THAT IS NOT YET SENT AND NUMBER OF LINES
  910.         % YET TO BE SENT AFTER EOT
  911.  
  912.     EDITBUF    % DESTINATION
  913.     EOT W@
  914.     OVERWRITE
  915.     IF IFCR "PREMATURE EOT ENCOUNTERED" MSG THEN
  916.     ;
  917.  
  918.  
  919. 'FINISH :    % USED AT END OF EDIT SESSION TO TRANSFER
  920.         % CONTENTS OF EDIT BUFFER AND ANY ADDITIONAL
  921.         % REMAINING TEXT IN THE INPUT FILE TO THE
  922.         % OUTPUT FILE.
  923.  
  924.     EDITBUF
  925.     BEGIN    % EMPTY EDIT BUFFER
  926.         DUP C@
  927.     IF
  928.         DUP
  929.         WRITELINE
  930.         NEXTLINE
  931.     REPEAT
  932.     DROP
  933.     NEWF
  934.     BEGIN    % TRANSFER REMAINDER OF INPUT FILE
  935.         INPUTFILE-STATUS
  936.         W@ -1 GT
  937.     IF
  938.         READLINE
  939.         LINEBUF WRITELINE
  940.     REPEAT
  941.     % SUMARIZE:
  942.     IFCR
  943.     "SUMARIZING: " MSG
  944.     INPUTFILE-STATUS W@ MINUS =
  945.     " LINES READ AND " MSG
  946.     OUTFILE-STATUS W@ MINUS =
  947.     " LINES WRITTEN." MSG
  948.     % CLOSING STATUS OF OUTPUT FILE:
  949.     +1 OUTFILE-STATUS W!
  950.     ;
  951.  
  952. 'MTDN        UNLINK
  953. 'LENTER        UNLINK
  954. '1POSARG?    UNLINK
  955. 'ARG#ERR    UNLINK
  956. '(DELETE)    UNLINK
  957. '1READ        UNLINK
  958. 'OLDLINE^    UNLINK
  959. 'EOT        UNLINK
  960. 'NEXTLINE    UNLINK
  961. 'ILLEGLIN    UNLINK
  962. 'LFIND        UNLINK
  963. 'LDIR        UNLINK
  964. 'LDDR        UNLINK
  965. '#GETLINE    UNLINK
  966. 'MTUP        UNLINK
  967. 'OVERWRITE    UNLINK
  968.  
  969. % TEST INPUT:
  970. 1 INPUT
  971. THIS IS THE FIRST LINE
  972. THIS IS THE SECOND LINE
  973. THIS IS THE THIRD LINE
  974. THIS IS THE FOURTH LINE
  975. THIS IS THE LAST LINE
  976.  
  977.  
  978. % HELP PACKAGE (JUNE 15, 1982)
  979.  
  980. 58 ':' CONSTANT
  981. 41 ')' CONSTANT
  982. 65 'A' CONSTANT
  983. 81 'Q' CONSTANT
  984. 'UC :  % l.c. -> U.C.
  985.      DUP
  986.      97 122 ..
  987.      IF
  988.         32 -
  989.      ELSE
  990.      THEN
  991.     ;
  992.  
  993. 'COL#? :    % RETURNS THE # OF ':' AT START OF LINE
  994. 0 LINEBUF 1+
  995. BEGIN DUP C@ :' EQ IF
  996. 1+ SWAP 1+ SWAP
  997. REPEAT
  998. DROP
  999. ;
  1000.  
  1001. 'TYIL : % READ FIRST CHAR FROM KEYBOARD; EXHAUST REST OF LINE
  1002.     TYI DUP NEWLINE -
  1003.     IF BEGIN TYI NEWLINE EQ END
  1004.     THEN
  1005. ;
  1006.  
  1007. 'MENU : % ON ENTRY NOTHING
  1008.         % ON EXIT: # OF LINES-1 (IF NO MENU, RETURN -1)
  1009.         -1
  1010.          BEGIN
  1011.            GETLINE
  1012.            COL#? LNOT IF
  1013.                        1+ DUP IF 
  1014.                                  DUP
  1015.                                  1- A' + TYO
  1016.                                  )'      TYO
  1017.                                          TAB
  1018.                               THEN
  1019.                        LINEBUF MSG
  1020.          REPEAT
  1021.         ;
  1022. 'TEXT :  % PRINTS LINES UNTIL A LINE STARTING WITH A ":"
  1023.          % NO STACK ACTIVITY
  1024.          BEGIN
  1025.            GETLINE
  1026.            COL#? LNOT
  1027.          IF
  1028.            LINEBUF 1+ LINEBUF C@ TYPE
  1029.          REPEAT
  1030.        ;
  1031. 'LOCATE :  % INPUT: SELECTION #, DELIM #
  1032.            % OUTPUT: NONE
  1033.           SWAP 1- 0
  1034.           DO
  1035.              BEGIN
  1036.                 GETLINE
  1037.                 COL#?
  1038.                 OVER
  1039.                 EQ
  1040.              END
  1041.            LOOP
  1042.            DROP
  1043.          ;
  1044. 'SELECTION : % INPUT: HIGHEST ACCEPTABLE
  1045.              % OUTPUT: POSITIVE # OF SELECTION
  1046.       0
  1047.        BEGIN
  1048.     DROP
  1049.           "ENTER LETTER OF SELECTION(Q TO ABORT):" MSG
  1050.            0 #LINES W!   % RESET LINE COUNT
  1051.            0 COLUMN W!   % RESET COL COUNT
  1052.           TYIL UC 
  1053.       DUP Q' EQ IF ABORT THEN
  1054.       A' - 1+
  1055.       DUP 1 3OVER ..
  1056.        END
  1057.        UNDER
  1058.       ;
  1059. '(HELP) :
  1060.       LIST OFF
  1061.       BEGIN
  1062.            MENU
  1063.            DUP GTZ  % DOES MENU EXIST?
  1064.       IF
  1065.            SELECTION
  1066.            COL#?
  1067.            LOCATE
  1068.       REPEAT
  1069.       DROP
  1070.       TEXT
  1071.     ;
  1072.  
  1073. 'HELP : % WILL PROVIDE THE USER WITH AN ONLINE FACILITY TO
  1074.           % LOOK UP THINGS 
  1075.     SP LNOT IF 'PISTOL.HLP THEN % SUPPLY DEFAULT NAME IF
  1076.                     % NONE IS PROVIDED
  1077.     LOAD
  1078.         (HELP)
  1079.         CR "HELP COMPLETED" MSG
  1080.         0 +7 TRANS W!   % RETURN CONSOLE INPUT
  1081.       ;
  1082. ':'        UNLINK
  1083. ')'        UNLINK
  1084. 'COL#?        UNLINK
  1085. 'MENU        UNLINK
  1086. 'TEXT        UNLINK
  1087. 'LOCATE        UNLINK
  1088. 'SELECTION    UNLINK
  1089. '(HELP)        UNLINK
  1090.  
  1091.  
  1092. ;F
  1093.  
  1094. 
  1095.          ;
  1096. 'SELECTION : % INPUT: HIGHEST ACCEPTABLE
  1097.              % OUTPUT: POSITIVE # OF SELECTION
  1098.       0
  1099.